home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / ilisp / completer.no-fun.el.z / completer.no-fun.el
Encoding:
Text File  |  1998-05-21  |  34.7 KB  |  1,014 lines

  1. ;;; -*-Emacs-Lisp-*-
  2. ;;;%Header
  3. ;;;
  4. ;;; Rcs_Info: completer.el,v 3.23 1993/09/03 02:05:07 ivan Rel $
  5. ;;;
  6. ;;; Partial completion mechanism for GNU Emacs.  Version 3.03
  7. ;;; Copyright (C) 1990, 1991, 1992 Chris McConnell, ccm@cs.cmu.edu.
  8. ;;; Thanks to Bjorn Victor for suggestions, testing, and patches for
  9. ;;; file completion. 
  10.  
  11. ;;; This file is part of GNU Emacs.
  12.  
  13. ;;; GNU Emacs is distributed in the hope that it will be useful,
  14. ;;; but WITHOUT ANY WARRANTY.  No author or distributor
  15. ;;; accepts responsibility to anyone for the consequences of using it
  16. ;;; or for whether it serves any particular purpose or works at all,
  17. ;;; unless he says so in writing.  Refer to the GNU Emacs General Public
  18. ;;; License for full details.
  19. ;;; Everyone is granted permission to copy, modify and redistribute
  20. ;;; GNU Emacs, but only under the conditions described in the
  21. ;;; GNU Emacs General Public License.   A copy of this license is
  22. ;;; supposed to have been given to you along with GNU Emacs so you
  23. ;;; can know your rights and responsibilities.  It should be in a
  24. ;;; file named COPYING.  Among other things, the copyright notice
  25. ;;; and this notice must be preserved on all copies.
  26.  
  27. ;;; When loaded, this file extends the standard completion mechanisms
  28. ;;; so that they perform pattern matching completions.  There is also
  29. ;;; an interface that allows it to be used by other programs.  The
  30. ;;; completion rules are:
  31. ;;;
  32. ;;; 1) If what has been typed matches any possibility, do normal
  33. ;;; completion. 
  34. ;;;
  35. ;;; 2) Otherwise, generate a regular expression such that
  36. ;;; completer-words delimit words and generate all possible matches.
  37. ;;; The variable completer-any-delimiter can be set to a character
  38. ;;; that matches any delimiter.  If it were " ", then "by  d" would be 
  39. ;;; byte-recompile-directory.  If completer-use-words is T, a match is
  40. ;;; unique if it is the only one with the same number of words.  If
  41. ;;; completer-use-words is NIL, a match is unique if it is the only
  42. ;;; possibility.  If you ask the completer to use its best guess, it
  43. ;;; will be the shortest match of the possibilities unless
  44. ;;; completer-exact is T.
  45. ;;;
  46. ;;; 3) For filenames, if completer-complete-filenames is T, each
  47. ;;; pathname component will be individually completed, otherwise only
  48. ;;; the final component will be completed.  If you are using a
  49. ;;; distributed file system like afs, you may want to set up a
  50. ;;; symbolic link in your home directory or add pathname components to
  51. ;;; completer-file-skip so that the pathname components that go across
  52. ;;; machines do not get expanded.
  53. ;;;
  54. ;;; SPACE, TAB, LFD, RET, and ? do normal completion if possible
  55. ;;; otherwise they do partial completion.  In addition, C-DEL will
  56. ;;; undo the last partial expansion or contraction.  M-RET will always
  57. ;;; complete to the current match before returning.  This is useful
  58. ;;; when any string is possible, but you want to complete to a string
  59. ;;; as when calling find-file.  The bindings can be changed by using
  60. ;;; completer-load-hook.
  61. ;;;
  62. ;;; Modes that use comint-dynamic-complete (like cmushell and ilisp)
  63. ;;; will also do partial completion as will M-tab in Emacs LISP.
  64. ;;;
  65. ;;; Examples:
  66. ;;; a-f     auto-fill-mode
  67. ;;; b--d    *beginning-of-defun or byte-recompile-directory
  68. ;;; by  d   *byte-recompile-directory if completer-any-delimiter is " "
  69. ;;; ~/i.e   *~/ilisp.el or ~/il-el.el or ~/ilisp.elc
  70. ;;; /u/mi/  /usr/misc/
  71. ;;;
  72.  
  73. ;;;%Globals
  74. ;;;%%Switches
  75. (defvar completer-load-hook nil
  76.   "Hook called when minibuffer partial completion is loaded.")
  77.  
  78. (defvar completer-disable nil
  79.   "*If T, turn off partial completion.  Use the command
  80. \\[completer-toggle] to set this.")
  81.  
  82. (defvar completer-complete-filenames t
  83.   "*If T, then each component of a filename will be completed,
  84. otherwise just the final component will be completed.")
  85.  
  86. (defvar completer-use-words nil ; jwz: this is HATEFUL!
  87.   "*If T, then prefer completions with the same number of words as the
  88. pattern.")
  89.  
  90. (defvar completer-words "---. <" 
  91.   "*Delimiters used in partial completions.  It should be a set of
  92. characters suitable for inclusion in a [] regular expression.")
  93.  
  94. (defvar completer-any-delimiter nil
  95.   "*If a character, then a delimiter in the pattern that matches the
  96. character will match any delimiter in completer-words.")
  97.  
  98. (defvar completer-file-skip "^cs/$\\|@sys\\|.edu/$\\|.gov/$\\|.com/$\\|:/$"
  99.   "*Regular expression for pathname components to not complete.")
  100.  
  101. (defvar completer-exact nil
  102.   "*If T, then you must have an exact match.  Otherwise, the shortest
  103. string that matches the pattern will be used.")
  104.  
  105. (defvar completer-cache-size 100
  106.   "*Size of cache to use for partially completed pathnames.")
  107.  
  108. (defvar completer-use-cache t
  109.   "*Set to nil to disable the partially completed pathname cache.")
  110.  
  111. ;;;%%Internal
  112. (defvar completer-last-pattern ""
  113.   "The last pattern expanded.")
  114.  
  115. (defvar completer-message nil
  116.   "T if temporary message was just displayed.")
  117.  
  118. (defvar completer-path-cache nil
  119.   "Cache of (path . choices) for completer.")
  120.  
  121. (defvar completer-string nil "Last completer string.")
  122. (defvar completer-table nil "Last completer table.")
  123. (defvar completer-pred nil "Last completer pred.")
  124. (defvar completer-mode nil "Last completer mode.")
  125. (defvar completer-result nil "Last completer result.")
  126.  
  127. ;;;%Utilities
  128. (defun completer-message (message &optional point)
  129.   "Display MESSAGE at optional POINT for two seconds."
  130.   (setq point (or point (point-max))
  131.     completer-message t)
  132.   (let ((end
  133.      (save-excursion
  134.        (goto-char point)
  135.        (insert message)
  136.        (point)))
  137.     (inhibit-quit t))
  138.     (sit-for 2)
  139.     (delete-region point end)
  140.     (if (and quit-flag 
  141.          ;;(not (eq 'lucid-19 ilisp-emacs-version-id))
  142.          (not (string-match "Lucid" emacs-version))
  143.          )
  144.     (setq quit-flag nil
  145.           unread-command-char 7))))
  146.  
  147. ;;;
  148. (defun completer-deleter (regexp choices &optional keep)
  149.   "Destructively remove strings that match REGEXP in CHOICES and
  150. return the modified list.  If optional KEEP, then keep entries that
  151. match regexp."
  152.   (let* ((choiceb choices)
  153.      choicep)
  154.     (if keep
  155.     (progn
  156.       (while (and choiceb (not (string-match regexp (car choiceb))))
  157.         (setq choiceb (cdr choiceb)))
  158.       (setq choicep choiceb)
  159.       (while (cdr choicep)
  160.         (if (string-match regexp (car (cdr choicep)))
  161.         (setq choicep (cdr choicep))
  162.         (rplacd choicep (cdr (cdr choicep))))))
  163.     (while (and choiceb (string-match regexp (car choiceb)))
  164.       (setq choiceb (cdr choiceb)))
  165.     (setq choicep choiceb)
  166.     (while (cdr choicep)
  167.       (if (string-match regexp (car (cdr choicep)))
  168.           (rplacd choicep (cdr (cdr choicep)))
  169.           (setq choicep (cdr choicep)))))
  170.     choiceb))
  171.  
  172. ;;;%%Regexp
  173. (defun completer-regexp (string delimiters any)
  174.   "Convert STRING into a regexp with words delimited by characters in
  175. DELIMITERS.  Any delimiter in STRING that is the same as ANY will
  176. match any delimiter."
  177.   (let* ((delimiter-reg (concat "[" delimiters "]"))
  178.      (limit (length string))
  179.      (pos 0)
  180.      (regexp "^"))
  181.     (while (and (< pos limit) (string-match delimiter-reg string pos))
  182.       (let* ((begin (match-beginning 0))
  183.          (end (match-end 0))
  184.          (delimiter (substring string begin end))
  185.          (anyp (eq (elt string begin) any)))
  186.     (setq regexp 
  187.           (format "%s%s[^%s]*%s" 
  188.               regexp
  189.               (regexp-quote (substring string pos begin))
  190.               (if anyp delimiters delimiter)
  191.               (if anyp delimiter-reg delimiter))
  192.           pos end)))
  193.     (if (<= pos limit)
  194.     (setq regexp (concat regexp 
  195.                  (regexp-quote (substring string pos limit)))))))
  196.  
  197. ;;;
  198. (defun completer-words (regexp string &optional limit)
  199.   "Return the number of words matching REGEXP in STRING up to LIMIT."
  200.   (setq limit (or limit 1000))
  201.   (let ((count 1)
  202.     (pos 0))
  203.     (while (and (string-match regexp string pos) (<= count limit))
  204.       (setq count (1+ count)
  205.         pos (match-end 0)))
  206.     count))
  207.  
  208. ;;;%Matcher
  209. (defun completer-matches (string choices delimiters any)
  210.     "Return STRING's matches in CHOICES using DELIMITERS and wildcard
  211. ANY to segment the strings."
  212.     (let* ((regexp (concat "[" delimiters "]"))
  213.        (from nil)
  214.        (to 0)
  215.        (pattern nil)
  216.        (len (length string))
  217.        (matches nil)
  218.        sub sublen choice word wordlen pat)
  219.       ;; Segment pattern
  220.       (while (< (or from 0) len)
  221.     (setq to (or (string-match regexp string (if from (1+ from))) len))
  222.     (if (eq (elt string (or from 0)) completer-any-delimiter)
  223.         (setq sub (substring string (if from (1+ from) 0) to)
  224.           sublen (- (length sub)))
  225.         (setq sub (substring string (or from 0) to)
  226.           sublen (length sub)))
  227.     (setq pattern (cons (cons sub sublen) pattern)
  228.           from to))
  229.       (setq pattern (reverse pattern))
  230.       ;; Find choices that match patterns
  231.       (setq regexp (concat "[" delimiters "]"))
  232.       (while choices
  233.     (setq choice (car choices)
  234.           word pattern 
  235.           from 0)
  236.     (while (and word from
  237.             (let* (begin end)
  238.               (if (< (setq wordlen (cdr (setq pat (car word)))) 0)
  239.               (setq begin (1+ from)
  240.                 end (+ begin (- wordlen)))
  241.               (setq begin from
  242.                 end (+ begin wordlen)))
  243.               (and (<= end (length choice))
  244.                (or (zerop wordlen)
  245.                    (string-equal 
  246.                 (car pat)
  247.                 (substring choice begin end))))))
  248.       (setq from (string-match regexp choice 
  249.                    (if (and (zerop from) (zerop wordlen))
  250.                        from
  251.                        (1+ from)))
  252.         word (cdr word)))
  253.     (if (not word) (setq matches (cons choice matches)))
  254.     (setq choices (cdr choices)))
  255.       matches))
  256.  
  257. ;;;
  258. (defun completer-choice (string choices delimiters use-words)
  259.   "Return the best match of STRING in CHOICES with DELIMITERS between
  260. words and T if it is unique.  A match is unique if it is the only
  261. possibility or when USE-WORDS the only possibility with the same
  262. number of words.  The shortest string of multiple possibilities will be
  263. the best match."
  264.   (or (if (null (cdr choices)) (cons (car choices) t))
  265.       (let* ((regexp (concat "[^" delimiters "]*[" delimiters "]"))
  266.          (words (if use-words (completer-words regexp string)))
  267.          (choice choices)
  268.          (unique-p nil)
  269.          (match nil)
  270.          (match-count nil)
  271.          (match-len 1000))
  272.     (while choice
  273.       (let* ((current (car choice))
  274.          (length (length current)))
  275.         (if match-count
  276.         (if (= (completer-words regexp current words) words)
  277.             (progn
  278.               (setq unique-p nil)
  279.               (if (< length match-len)
  280.               (setq match current
  281.                 match-len length))))
  282.         (if (and use-words 
  283.              (= (completer-words regexp current words) words))
  284.             (setq match current
  285.               match-len length
  286.               match-count t
  287.               unique-p t)
  288.             (if (< length match-len)
  289.             (setq match current
  290.                   match-len length)))))
  291.       (setq choice (cdr choice)))
  292.     (cons match unique-p))))
  293.  
  294. ;;;%Completer
  295. ;;;%%Utilities
  296. (defun completer-region (delimiters)
  297.   "Return the completion region bounded by characters in DELIMITERS
  298. for the current buffer assuming that point is in it."
  299.   (cons (save-excursion (skip-chars-backward delimiters) (point))
  300.     (save-excursion (skip-chars-forward delimiters) (point))))
  301.      
  302. ;;;
  303. (defun completer-last-component (string)
  304.   "Return the start of the last filename component in STRING."
  305.   (let ((last (1- (length string)) )
  306.     (match 0)
  307.     (end 0))
  308.     (while (and (setq match (string-match "/" string end)) (< match last))
  309.       (setq end (1+ match)))
  310.     end))
  311.  
  312. ;;;
  313. (defun completer-match-record (string matches delimiters any dir mode)
  314.   "Return (match lcs choices unique) for STRING in MATCHES with
  315. DELIMITERS or ANY wildcards and DIR if a filename when in MODE."
  316.   (let ((pattern (if dir
  317.              (substring string (completer-last-component string))
  318.              string)))
  319.     (setq matches (completer-matches pattern matches delimiters any))
  320.     (if (cdr matches)
  321.     (let ((match
  322.            (if (not completer-exact)
  323.            (completer-choice
  324.             pattern matches delimiters completer-use-words)))
  325.           (lcs (concat dir (try-completion "" (mapcar 'list matches)))))
  326.       (list (if match (concat dir (car match)))
  327.         lcs
  328.         matches (cdr match)))
  329.       (if matches 
  330.       (let ((match (concat dir (car matches))))
  331.         (list match match matches t))
  332.     (list nil nil nil nil)))))
  333.  
  334. ;;;%%Complete file
  335. (defun completer-extension-regexp (extensions)
  336.   "Return a regexp that matches any of EXTENSIONS."
  337.   (let ((regexp "\\("))
  338.     (while extensions
  339.       (setq regexp (concat regexp (car extensions)
  340.                (if (cdr extensions) "\\|"))
  341.         extensions (cdr extensions)))
  342.     (concat regexp "\\)$")))
  343.  
  344. ;;;
  345. (defun completer-flush ()
  346.   "Flush completer's pathname cache."
  347.   (interactive)
  348.   (setq completer-path-cache nil))
  349.  
  350. ;;;
  351. (defun completer-cache (path pred words any mode)
  352.   "Check to see if PATH is in path cache with PRED, WORDS, ANY and
  353. MODE."
  354.   (let* ((last nil)
  355.      (ptr completer-path-cache)
  356.      (size 0) 
  357.      (result nil))
  358.     (if completer-use-cache
  359.     (while ptr
  360.       (let ((current (car (car ptr))))
  361.         (if (string-equal current path)
  362.         (progn
  363.           (if last
  364.               (progn
  365.             (rplacd last (cdr ptr))
  366.             (rplacd ptr completer-path-cache)
  367.             (setq completer-path-cache ptr)))
  368.           (setq result (cdr (car ptr))
  369.             ptr nil))
  370.           (if (cdr ptr) (setq last ptr))
  371.           (setq size (1+ size)
  372.             ptr (cdr ptr))))))
  373.     (or result
  374.     (let* ((choices 
  375.         (completer path 'read-file-name-internal pred words any
  376.                mode t)))
  377.       (if (and (or (car (cdr (cdr (cdr choices))))
  378.                (string= path (car choices)))
  379.            (eq (elt (car choices) (1- (length (car choices)))) ?/))
  380.           (progn 
  381.         (if (>= size completer-cache-size) (rplacd last nil))
  382.         (setq completer-path-cache 
  383.               (cons (cons path choices) completer-path-cache))))
  384.       choices))))
  385.  
  386. ;;;
  387. (defun completer-file (string pred words any mode)
  388.   "Return (match common-substring matches unique-p) for STRING using
  389. read-file-name-internal for choices that pass PRED using WORDS to
  390. delimit words.  Optional ANY is a delimiter that matches any of the
  391. delimiters in WORD.  If optional MODE is nil or 'help then possible
  392. matches will always be returned."
  393.   (let* ((case-fold-search completion-ignore-case)
  394.      (last (and (eq mode 'exit-ok) (completer-last-component string)))
  395.      (position
  396.       ;; Special hack for CMU RFS filenames
  397.       (if (string-match "^/\\.\\./[^/]*/" string)
  398.           (match-end 0)
  399.           (string-match "[^~/]" string)))
  400.      (new (substring string 0 position))
  401.      (user (if (string= new "~")
  402.            (setq new (file-name-directory (expand-file-name new)))))
  403.      (words (concat words "/"))
  404.      (len (length string))
  405.      (choices nil)
  406.      end
  407.      (old-choices (list nil nil nil nil)))
  408.     (while position
  409.       (let* ((begin (string-match "/" string position))
  410.          (exact-p nil))
  411.     (setq end (if begin (match-end 0))
  412.           choices
  413.           ;; Ends with a /, so check files in directory
  414.           (if (and (memq mode '(nil help)) (= position len))
  415.           (completer-match-record 
  416.            ""
  417.            ;; This assumes that .. and . come at the end
  418.            (let* ((choices
  419.                (all-completions new 'read-file-name-internal))
  420.               (choicep choices))
  421.              (if (string= (car choicep) "../")
  422.              (cdr (cdr choicep))
  423.              (while (cdr choicep)
  424.                (if (string= (car (cdr choicep)) "../")
  425.                    (rplacd choicep nil))
  426.                (setq choicep (cdr choicep)))
  427.              choices))
  428.            words any new mode)
  429.           (if (eq position last)
  430.               (let ((new (concat new (substring string position))))
  431.             (list new new nil t))
  432.               (let ((component (substring string position end)))
  433.             (if (and end
  434.                  (string-match completer-file-skip component))
  435.                 ;; Assume component is complete
  436.                 (list (concat new component) 
  437.                   (concat new component)
  438.                   nil t)
  439.                 (completer-cache
  440.                  (concat new component)
  441.                  pred words any mode))))))
  442.     ;; Keep going if unique or we match exactly
  443.     (if (or (car (cdr (cdr (cdr choices))))
  444.         (setq exact-p
  445.               (string= (concat new (substring string position end))
  446.                    (car choices))))
  447.         (setq old-choices
  448.           (let* ((lcs (car (cdr choices)))
  449.              (matches (car (cdr (cdr choices))))
  450.              (slash (and lcs (string-match "/$" lcs))))
  451.             (list nil
  452.               (if slash (substring lcs 0 slash) lcs)
  453.               (if (and (cdr matches) 
  454.                    (or (eq mode 'help) (not exact-p)))
  455.                   matches)
  456.               nil))
  457.           new (car choices)
  458.           position end)
  459.         ;; Its ok to not match user names because they may be in
  460.         ;; different root directories
  461.         (if (and (= position 1) (= (elt string 0) ?~))
  462.         (setq new (substring string 0 end)
  463.               choices (list new new (list new) t)
  464.               user nil
  465.               position end)
  466.         (setq position nil)))))
  467.     (if (not (car choices))
  468.     (setq choices old-choices))
  469.     (if (and (car choices)
  470.          (not (eq mode 'help))
  471.          (not (car (cdr (cdr (cdr choices))))))
  472.     ;; Try removing completion ignored extensions
  473.     (let* ((extensions
  474.         (completer-extension-regexp completion-ignored-extensions))
  475.            (choiceb (car (cdr (cdr choices))))
  476.            (choicep choiceb)
  477.            (isext nil)
  478.            (noext nil))
  479.       (while choicep
  480.         (if (string-match extensions (car choicep))
  481.         (setq isext t)
  482.         (setq noext t))
  483.         (if (and isext noext)
  484.         ;; There are matches besides extensions
  485.         (setq choiceb (completer-deleter extensions choiceb)
  486.               choicep nil)
  487.         (setq choicep (cdr choicep))))
  488.       (if (and isext noext)
  489.           (setq choices
  490.             (completer-match-record 
  491.              (if end (substring string end) "")
  492.              choiceb words any
  493.              (file-name-directory (car (cdr choices)))
  494.              mode)))))
  495.     (if user
  496.     (let ((match (car choices))
  497.           (lcs (car (cdr choices)))
  498.           (len (length user)))
  499.       (setq choices
  500.         (cons (if match (concat "~" (substring match len)))
  501.               (cons (if lcs (concat "~" (substring lcs len)))
  502.                 (cdr (cdr choices)))))))
  503.     choices))
  504.  
  505. ;;;%Exported program interface
  506. ;;;%%Completer
  507. (defun completer (string table pred words
  508.              &optional any mode file-p)
  509.   "Return (match common-substring matches unique-p) for STRING in
  510. TABLE for choices that pass PRED using WORDS to delimit words.  If the
  511. flag completer-complete-filenames is T and the table is
  512. read-file-name-internal, then filename components will be individually
  513. expanded.  Optional ANY is a delimiter that can match any delimiter in
  514. WORDS.  Optional MODE is nil for complete, 'help for help and 'exit
  515. for exit."
  516.   (if (and (stringp completer-string) 
  517.        (string= string completer-string)
  518.        (eq table completer-table)
  519.        (eq pred completer-pred)
  520.        (not file-p)
  521.        (or (eq mode completer-mode)
  522.            (not (memq table '(read-file-name-internal
  523.                   read-directory-name-internal)))))
  524.       completer-result
  525.       (setq 
  526.        completer-string ""
  527.        completer-table table
  528.        completer-pred pred
  529.        completer-mode mode
  530.        completer-result
  531.        (if (and completer-complete-filenames
  532.         (not file-p) (eq table 'read-file-name-internal))
  533.        (completer-file string pred words any mode)
  534.        (let* ((file-p (or file-p (eq table 'read-file-name-internal)))
  535.           (case-fold-search completion-ignore-case)
  536.           (pattern (concat "[" words "]"))
  537.           (component (if file-p (completer-last-component string)))
  538.           (dir (if component (substring string 0 component)))
  539.           (string (if dir (substring string component) string))
  540.           (has-words (or (string-match pattern string)
  541.                  (length string))))
  542.          (if (and file-p (string-match "^\\$" string))
  543.          ;; Handle environment variables
  544.          (let ((match
  545.             (getenv (substring string 1 
  546.                        (string-match "/" string)))))
  547.            (if match (setq match (concat match "/")))
  548.            (list match match (list match) match))
  549.          (let* ((choices
  550.              (all-completions 
  551.               (concat dir (substring string 0 has-words))
  552.               table pred))
  553.             (regexp (completer-regexp string words any)))
  554.            (if choices
  555.                (completer-match-record 
  556.             string 
  557.             (completer-deleter regexp choices t) 
  558.             words any dir mode)
  559.                (list nil nil nil nil))))))
  560.        completer-string string)
  561.       completer-result))
  562.  
  563. ;;;%%Display choices
  564. (defun completer-display-choices (choices &optional match message end
  565.                       display)
  566.   "Display the list of possible CHOICES with optional MATCH, MESSAGE,
  567. END and DISPLAY.  If MATCH is non-nil, it will be flagged as the best
  568. guess.  If there are no choices, display MESSAGE.  END is where to put
  569. temporary messages.  If DISPLAY is present then it will be called on
  570. each possible completion and should return a string."
  571.   (if choices
  572.       (with-output-to-temp-buffer " *Completions*"
  573.     (if (cdr choices) 
  574.         (display-completion-list
  575.          (sort
  576.           (if display
  577.           (let ((old choices)
  578.             (new nil))
  579.             (while old
  580.               (setq new (cons (funcall display (car old)) new)
  581.                 old (cdr old)))
  582.             new)
  583.         (copy-sequence choices))
  584.           (function (lambda (x y)
  585.               (string-lessp (or (car-safe x) x)
  586.                     (or (car-safe y) y)))))))
  587.     (if match
  588.         (save-excursion
  589.           (set-buffer " *Completions*")
  590.           (goto-char (point-min))
  591.           (insert "Guess = " match (if (cdr choices) ", " "")))))
  592.       (beep)
  593.       (completer-message (or message " (No completions)") end)))
  594.  
  595. ;;;%%Goto
  596. (defun completer-goto (match lcs choices unique delimiters words 
  597.                  &optional mode display)
  598.   "MATCH is the best match, LCS is the longest common substring of all
  599. of the matches.  CHOICES is a list of the possibilities, UNIQUE
  600. indicates if MATCH is unique.  DELIMITERS are possible bounding
  601. characters for the completion region.  WORDS are the characters that
  602. delimit the words for partial matches.  Replace the region bounded by
  603. delimiters with the match if unique and the lcs otherwise unless
  604. optional MODE is 'help.  Then go to the part of the string that
  605. disambiguates choices using WORDS to separate words and display the
  606. possibilities if the string was not extended.  If optional DISPLAY is
  607. present then it will be called on each possible completion and should
  608. return a string."
  609.   (setq completer-message nil)
  610.   (let* ((region (completer-region delimiters))
  611.      (start (car region))
  612.      (end (cdr region))
  613.      (string (buffer-substring start end))
  614.      (file-p (string-match "[^ ]*\\(~\\|/\\|$\\)" string))
  615.      (no-insert (eq mode 'help))
  616.      (message t)
  617.      (new (not (string= (buffer-substring start (point)) lcs))))
  618.     (if unique
  619.     (if no-insert
  620.         (progn
  621.           (goto-char end)
  622.           (completer-display-choices choices match nil end display))
  623.         (if (string= string match)
  624.         (if (not file-p) 
  625.             (progn (goto-char end)
  626.                (completer-message " (Sole completion)" end)))
  627.         (completer-insert match delimiters)))
  628.     ;;Not unique
  629.     (if lcs
  630.         (let* ((regexp 
  631.             (concat "[" words (if file-p "/") "]"))
  632.            (words (completer-words regexp lcs))
  633.            point)
  634.           ;; Go to where its ambiguous
  635.           (goto-char start)
  636.           (if (not no-insert)
  637.           (progn 
  638.             (insert lcs)
  639.             (setq completer-last-pattern 
  640.               (list string delimiters (current-buffer) start)
  641.               start (point)
  642.               end (+ end (length lcs)))))
  643.           ;; Skip to the first delimiter in the original string
  644.           ;; beyond the ambiguous point and keep from there on
  645.           (if (re-search-forward regexp end 'move words)
  646.           (progn
  647.             (if (and (not no-insert) match)
  648.             (let ((delimiter
  649.                    (progn
  650.                  (string-match lcs match)
  651.                  (substring match (match-end 0)
  652.                         (1+ (match-end 0))))))
  653.               (if (string-match regexp delimiter)
  654.                   (insert delimiter))))
  655.             (forward-char -1)))
  656.           (if (not no-insert) 
  657.           (progn
  658.             (setq end (- end (- (point) start)))
  659.             (delete-region start (point))))))
  660.     (if choices
  661.         (if (or no-insert (not new))
  662.         (completer-display-choices choices match nil end display))
  663.         (if file-p 
  664.         (progn 
  665.           (if (not (= (point) end)) (forward-char 1))
  666.           (if (not (save-excursion (re-search-forward "/" end t)))
  667.               (goto-char end))))
  668.         (if message
  669.         (progn
  670.           (beep)
  671.           (completer-message (if no-insert 
  672.                      " (No completions)"
  673.                      " (No match)")
  674.                      end)))))))        
  675.  
  676. ;;;%Exported buffer interface
  677. ;;;%%Complete and go
  678. (defun completer-complete-goto (delimiters words table pred 
  679.                        &optional no-insert display)
  680.   "Complete the string bound by DELIMITERS using WORDS to bound words
  681. for partial matches in TABLE with PRED and then insert the longest
  682. common substring unless optional NO-INSERT and go to the point of
  683. ambiguity.  If optional DISPLAY, it will be called on each match when
  684. possible completions are shown and should return a string."
  685.   (let* ((region (completer-region delimiters)))
  686.     (apply 'completer-goto 
  687.        (append (completer (buffer-substring (car region) (cdr region))
  688.                   table pred words completer-any-delimiter
  689.                   no-insert)
  690.           (list delimiters words no-insert display)))))
  691.  
  692. ;;;%%Undo
  693. (defun completer-insert (match delimiters &optional buffer undo)
  694.   "Replace the region bounded with characters in DELIMITERS by MATCH
  695. and save it so that it can be restored by completer-undo."
  696.   (let* ((region (completer-region delimiters))
  697.      (start (car region))
  698.      (end (cdr region)))
  699.     (if (and undo (or (not (= start undo)) 
  700.               (not (eq (current-buffer) buffer))))
  701.     (error "No previous pattern")
  702.     (setq completer-last-pattern (list (buffer-substring start end) 
  703.                        delimiters
  704.                        (current-buffer)
  705.                        start))
  706.     (delete-region start end)
  707.     (goto-char start)
  708.     (insert match))))
  709.  
  710. ;;;
  711. (defun completer-undo ()
  712.   "Swap the last expansion and the last match pattern."
  713.   (interactive)
  714.   (if completer-last-pattern
  715.       (apply 'completer-insert completer-last-pattern)
  716.       (error "No previous pattern")))
  717.  
  718. ;;;%Minibuffer specific code
  719. ;;;%%Utilities
  720. (defun completer-minibuf-string ()
  721.   "Remove dead filename specs from the minibuffer as delimited by //
  722. or ~ or $ and return the resulting string."
  723.   (save-excursion
  724.     (goto-char (point-max))
  725.     (if (and (eq minibuffer-completion-table 'read-file-name-internal)
  726.          (re-search-backward "//\\|/~\\|.\\$" nil t))
  727.     (delete-region (point-min) (1+ (point))))
  728.     (buffer-substring (point-min) (point-max))))
  729.  
  730. ;;;
  731. (defun completer-minibuf-exit ()
  732.   "Exit and clear pattern."
  733.   (interactive)
  734.   (setq completer-last-pattern nil)
  735.   (exit-minibuffer))
  736.  
  737. ;;;
  738. (defun completer-new-cmd (cmd)
  739.   "Return T if we can't execute the old minibuffer version of CMD."
  740.   (if (or completer-disable
  741.       (let ((string (completer-minibuf-string)))
  742.         (or
  743.          (not (string-match
  744.            (concat "[" completer-words "/~]")
  745.            string))
  746.           (condition-case ()
  747.           (let ((completion
  748.              (try-completion string
  749.                      minibuffer-completion-table
  750.                      minibuffer-completion-predicate)))
  751.             (if (eq minibuffer-completion-table
  752.                 'read-file-name-internal)
  753.             ;; Directories complete as themselves
  754.             (and completion
  755.                  (or (not (string= string completion))
  756.                  (file-exists-p completion)))
  757.             completion))
  758.         (error nil)))))
  759.       (progn
  760.     (funcall cmd)
  761.     nil)
  762.       t))
  763.  
  764. ;;;
  765. (defun completer-minibuf (&optional mode)
  766.   "Partial completion of minibuffer expressions.  Optional MODE is
  767. 'help for help and 'exit for exit.
  768.  
  769. If what has been typed so far matches any possibility normal
  770. completion will be done.  Otherwise, the string is considered to be a
  771. pattern with words delimited by the characters in
  772. completer-words.  If completer-exact is T, the best match will be
  773. the shortest one with the same number of words as the pattern if
  774. possible and otherwise the shortest matching expression.  If called
  775. with a prefix, caching will be temporarily disabled.
  776.  
  777. Examples:
  778. a-f     auto-fill-mode
  779. r-e     rmail-expunge
  780. b--d    *begining-of-defun or byte-recompile-directory
  781. by  d   *byte-recompile-directory if completer-any-delimiter is \" \"
  782. ~/i.e   *~/ilisp.el or ~/il-el.el or ~/ilisp.elc
  783. /u/mi/  /usr/misc/"
  784.   (interactive)
  785.   (append
  786.    (let ((completer-use-cache (not (or (not completer-use-cache)
  787.                        current-prefix-arg))))
  788.      (completer (completer-minibuf-string)
  789.         minibuffer-completion-table
  790.         minibuffer-completion-predicate
  791.         completer-words
  792.         completer-any-delimiter
  793.         mode))
  794.    (list "^" completer-words mode)))
  795.  
  796. ;;;%%Commands
  797. (defun completer-toggle ()
  798.   "Turn partial completion on or off."
  799.   (interactive)
  800.   (setq completer-disable (not completer-disable))
  801.   (message (if completer-disable 
  802.            "Partial completion OFF"
  803.            "Partial completion ON")))
  804.  
  805. ;;;
  806. (defvar completer-old-help
  807.   (lookup-key minibuffer-local-must-match-map "?")
  808.   "Old binding of ? in minibuffer completion map.")
  809. (defun completer-help ()
  810.   "Partial completion minibuffer-completion-help.  
  811. See completer-minibuf for more information."
  812.   (interactive)
  813.   (if (completer-new-cmd completer-old-help)
  814.       (apply 'completer-goto (completer-minibuf 'help))))
  815.  
  816. ;;;
  817. (defvar completer-old-completer
  818.   (lookup-key minibuffer-local-must-match-map "\t")
  819.   "Old binding of TAB in minibuffer completion map.")
  820. (defun completer-complete ()
  821.   "Partial completion minibuffer-complete.
  822. See completer-minibuf for more information."
  823.   (interactive)
  824.   (if (completer-new-cmd completer-old-completer)
  825.       (apply 'completer-goto (completer-minibuf))))
  826.  
  827. ;;;
  828. (defvar completer-old-word
  829.   (lookup-key minibuffer-local-must-match-map " ")
  830.   "Old binding of SPACE in minibuffer completion map.")
  831. (defun completer-word ()
  832.   "Partial completion minibuffer-complete.
  833. See completer-minibuf for more information."
  834.   (interactive)
  835.   (if (eq completer-any-delimiter ?\ )
  836.       (insert ?\ )
  837.       (if (completer-new-cmd completer-old-word)
  838.       (apply 'completer-goto (completer-minibuf)))))
  839.  
  840. ;;; 
  841. (defvar completer-old-exit
  842.   (lookup-key minibuffer-local-must-match-map "\n")
  843.   "Old binding of RET in minibuffer completion map.")
  844. (defun completer-exit ()
  845.   "Partial completion minibuffer-complete-and-exit.
  846. See completer-minibuf for more information."
  847.   (interactive)
  848.   (if (completer-new-cmd completer-old-exit)
  849.       (let* ((completions (completer-minibuf 'exit))
  850.          (match (car completions))
  851.          (unique-p (car (cdr (cdr (cdr completions))))))
  852.     (apply 'completer-goto completions)
  853.     (if unique-p
  854.         (completer-minibuf-exit)
  855.         (if match
  856.         (progn (completer-insert match "^")
  857.                (if minibuffer-completion-confirm
  858.                (completer-message " (Confirm)")
  859.                (completer-minibuf-exit)))
  860.         (if (not completer-message) (beep)))))))
  861.  
  862. ;;;
  863. (defun completer-match-exit ()
  864.   "Exit the minibuffer with the current best match."
  865.   (interactive)
  866.   (let* ((completions (completer-minibuf 'exit))
  867.      (guess (car completions)))
  868.     (if (not guess) 
  869.     ;; OK if last filename component doesn't match
  870.     (setq completions (completer-minibuf 'exit-ok)
  871.           guess (car completions)))
  872.     (if guess
  873.     (progn
  874.       (goto-char (point-min))
  875.       (insert guess)
  876.       (delete-region (point) (point-max))
  877.       (exit-minibuffer))
  878.     (apply 'completer-goto completions))))
  879.  
  880. ;;;%%Keymaps
  881. (define-key minibuffer-local-completion-map "\C-_"  'completer-undo)
  882. (define-key minibuffer-local-completion-map "\t"    'completer-complete)
  883. (define-key minibuffer-local-completion-map " "     'completer-word)
  884. (define-key minibuffer-local-completion-map "?"     'completer-help)
  885. (define-key minibuffer-local-completion-map "\n"    'completer-minibuf-exit)
  886. (define-key minibuffer-local-completion-map "\r"    'completer-minibuf-exit)
  887. (define-key minibuffer-local-completion-map "\M-\n" 'completer-match-exit)
  888. (define-key minibuffer-local-completion-map "\M-\r" 'completer-match-exit)
  889.  
  890. (define-key minibuffer-local-must-match-map "\C-_"  'completer-undo)
  891. (define-key minibuffer-local-must-match-map "\t"    'completer-complete)
  892. (define-key minibuffer-local-must-match-map " "     'completer-word)
  893. (define-key minibuffer-local-must-match-map "\n"    'completer-exit)
  894. (define-key minibuffer-local-must-match-map "\r"    'completer-exit)
  895. (define-key minibuffer-local-must-match-map "?"     'completer-help)
  896. (define-key minibuffer-local-must-match-map "\M-\n" 'completer-match-exit)
  897. (define-key minibuffer-local-must-match-map "\M-\r" 'completer-match-exit)
  898.  
  899. ;;;%comint 
  900. (defun completer-comint-dynamic-list-completions (completions)
  901.   "List in help buffer sorted COMPLETIONS.
  902. Typing SPC flushes the help buffer."
  903.   (completer-comint-dynamic-complete-1 nil 'help))
  904.  
  905. (defun completer-comint-dynamic-complete-filename ()
  906.   "Dynamically complete the filename at point."
  907.   (completer-comint-dynamic-complete-1 nil t))
  908.  
  909. ;;;
  910. (defun completer-comint-dynamic-complete-1 (&optional undo mode)
  911.   "Complete the previous filename or display possibilities if done
  912. twice in a row.  If called with a prefix, undo the last completion."
  913.   (interactive "P")
  914.   (if undo
  915.       (completer-undo)
  916.     ;; added by jwz: don't cache completions in shell buffer!
  917.     (setq completer-string nil)
  918.     (let ((conf (current-window-configuration)));; lemacs change
  919.       (completer-complete-goto 
  920.        "^ \t\n\""
  921.        completer-words
  922.        'read-file-name-internal
  923.        default-directory
  924.        mode)
  925.       ;; lemacs change
  926.       (if (eq mode 'help) (comint-restore-window-config conf))
  927.       )))
  928. ;(fset 'comint-dynamic-complete 'completer-comint-dynamic-complete)
  929. (fset 'comint-dynamic-complete-filename
  930.       'completer-comint-dynamic-complete-filename)
  931. (fset 'comint-dynamic-list-completions 
  932.       'completer-comint-dynamic-list-completions)
  933.  
  934. ;;; Set the functions again if comint is loaded
  935. (setq comint-load-hook 
  936.       (cons (function (lambda ()
  937. ;;          (fset 'comint-dynamic-complete 
  938. ;;            'completer-comint-dynamic-complete)
  939.             (fset 'comint-dynamic-complete-filename
  940.                   'completer-comint-dynamic-complete-filename)
  941.           (fset 'comint-dynamic-list-completions 
  942.             'completer-comint-dynamic-list-completions)))
  943.         (if (and (boundp 'comint-load-hook) comint-load-hook)
  944.         (if (consp comint-load-hook) 
  945.             (if (eq (car comint-load-hook) 'lambda)
  946.             (list comint-load-hook)
  947.             comint-load-hook)
  948.             (list comint-load-hook)))))
  949.  
  950. ;;;%lisp-complete-symbol
  951. (defun lisp-complete-symbol (&optional mode)
  952.   "Perform partial completion on Lisp symbol preceding point.  That
  953. symbol is compared against the symbols that exist and any additional
  954. characters determined by what is there are inserted.  If the symbol
  955. starts just after an open-parenthesis, only symbols with function
  956. definitions are considered.  Otherwise, all symbols with function
  957. definitions, values or properties are considered.  If called with a
  958. negative prefix, the last completion will be undone."
  959.   (interactive "P")
  960.   (if (< (prefix-numeric-value mode) 0)
  961.       (completer-undo)
  962.       (let* ((end (save-excursion (skip-chars-forward "^ \t\n)]}\"") (point)))
  963.          (beg (save-excursion
  964.             (backward-sexp 1)
  965.             (while (= (char-syntax (following-char)) ?\')
  966.               (forward-char 1))
  967.             (point)))
  968.          (pattern (buffer-substring beg end))
  969.          (predicate
  970.           (if (eq (char-after (1- beg)) ?\()
  971.           'fboundp
  972.           (function (lambda (sym)
  973.             (or (boundp sym) (fboundp sym)
  974.             (symbol-plist sym))))))
  975.          (completion (try-completion pattern obarray predicate)))
  976.        (cond ((eq completion t))
  977.           ((null completion)
  978.            (completer-complete-goto
  979.         "^ \t\n\(\)[]{}'`" completer-words
  980.         obarray predicate 
  981.         nil
  982.         (if (not (eq predicate 'fboundp))
  983.             (function (lambda (choice)
  984.               (if (fboundp (intern choice))
  985.               (list choice " <f>")
  986.               choice))))))
  987.           ((not (string= pattern completion))
  988.            (delete-region beg end)
  989.            (insert completion))
  990.           (t
  991.            (message "Making completion list...")
  992.            (let ((list (all-completions pattern obarray predicate)))
  993.          (or (eq predicate 'fboundp)
  994.              (let (new)
  995.                (while list
  996.              (setq new (cons (if (fboundp (intern (car list)))
  997.                          (list (car list) " <f>")
  998.                          (car list))
  999.                      new))
  1000.              (setq list (cdr list)))
  1001.                (setq list (nreverse new))))
  1002.          (with-output-to-temp-buffer "*Help*"
  1003.            (display-completion-list
  1004.             (sort list (function (lambda (x y)
  1005.                        (string-lessp
  1006.                         (or (car-safe x) x)
  1007.                         (or (car-safe y) y))))))))
  1008.            (message "Making completion list...%s" "done"))))))
  1009.  
  1010. ;;;%Hooks
  1011. (provide 'completer)
  1012. (run-hooks 'completer-load-hook)
  1013.  
  1014.